BBS in a Box 3/BBS in a box - Trilogy III.iso/Files/Prog/S/SERIAL.PAS

Pascal/Delphi Source File | 1991-11-07 | 5.5 KB | 233 lines | [TEXT/MSWD]

{ Serial Demo program adapted from SerialDemo.c by Mark Y. Geschelin. }
{ This program uses the modem port to send and recieve characters. }
{ It functions as a very simple terminal emulator.  This is meant to be an }
{ example of the use of the Serial Manager, not an example of how to code }
{ a terminal emulator!! }
{ Compile this program with Runtime.lib, Interface.lib, and Serial.p }
{ Pascal port by Phil Shapiro and Mark Y. Geschelin, ) 1990 Symantec Corp. }
{  Revised: }
{        7-03-90    Myg    Added handshaking and made buffer larger as well as some special}
{                            processing because I found the default behavior really annoying during testing}
{        9-26-91    PLS    Fixed to use OpenDriver instead of RAMSDOpen, other various aesthetic}
{                            improvements.  Also added "back tic" escape route for old macs. }

program SerialDemo;
    uses
        Serial;
    const
        EscapeChar = Chr($1B);
        BackTicChar = '`';
        LinefeedChar = $0A;
        BackspaceChar = $08;
        DeleteChar = $7F;
        Echo = FALSE;
        recieveRaw = FALSE;        { Set this to true to see the raw data as sent }
        transmitRaw = FALSE;        { Set this to true to send the data exactly as typed }
        BufferLen = 1024;
        xonchar = Chr($11);
        xoffchar = Chr($13);
        hatchar = $5E;
        OutDriverName = '.AOut';
        InDriverName = '.AIn';
    type
        BufferType = packed array[1..BufferLen] of SignedByte;
        BufferPtr = ^BufferType;
    var
        inBuf: BufferPtr;                        { our buffer }
        serialManagerBuffer: BufferPtr;    { the buffer for the serial manager }
        inRefNum, outRefNum: integer;

    function AvailChar: Char;            { poll for data from keyboard }
        var
            c: Char;
            event: EventRecord;

        function InterpretOutput (x: SignedByte): Char;
        begin
            if transmitRaw then
                InterpretOutput := Char(x)
            else
                case x of
                    BackspaceChar:
                        InterpretOutput := Char(DeleteChar);
                    LinefeedChar:
                        ;
                    otherwise
                        InterpretOutput := Char(x);
                end;
        end;

    begin
        c := Char(0);
        if GetNextEvent(everyevent, event) then
            if (event.what = keyDown) or (event.what = autoKey) then
                c := InterpretOutput(BAND(event.message, charCodeMask));
        AvailChar := c;
    end;

    procedure CleanUp;
        var
            dummy: OSErr;
    begin
        if inbuf <> nil then
            dispose(inbuf);
        if serialManagerBuffer <> nil then
            dispose(serialManagerBuffer);
        if inRefNum <> 0 then
            dummy := CloseDriver(inRefNum);
        if outRefNum <> 0 then
            dummy := CloseDriver(outRefNum);
    end;

    procedure DisplayBuff (count: Longint);
        var
            i: Longint;
            hatflag: boolean;

        procedure Interpret (x: SignedByte);
        begin
            if hatflag then
                hatflag := false
            else
                begin
                    if recieveRaw then
                        write(Char(x))
                    else
                        case x of
                            LinefeedChar, BackspaceChar:
                                ;
                            hatchar:
                                hatflag := true;
                            otherwise
                                write(Char(x));
                        end;
                end;
        end;

    begin
        hatflag := false;
        for i := 1 to count do
            Interpret(inbuf^[i]);
    end;

    procedure GetSerialChars (count: Longint);
        var
            err: OSErr;
    begin
        err := FSRead(inRefNum, count, Ptr(inbuf));
    end;

    function SerialCharsAvail: integer;
        var
            count: Longint;
            err: OSErr;
    begin
        err := SerGetBuf(inRefNum, count);
        SerialCharsAvail := count
    end;

    procedure SerialWrite (ch: Char);
        var
            err: OSErr;
            num: Longint;
            cha: SignedByte;
    begin
        num := 1;
        cha := SignedByte(ch);
        err := FSWrite(outRefNum, num, @cha);
    end;

    function SerialInit: OSErr;
        var
            err: OStErr;
            flags: SerShk;

        procedure FailOSErr (err: OSErr);
        begin
            if err <> noErr then
                begin
                    SerialInit := err;
                    exit(SerialInit);
                end;
        end;

    begin
        outRefNum := 0;
        inRefNum := 0;
        serialManagerBuffer := nil;
        inbuf := nil;
        SerialInit := noErr;
        with flags do
            begin
                fxon := byte(TRUE);
                finx := byte(TRUE);
                xon := xonchar;
                xoff := xoffchar;
            end;
        new(serialManagerBuffer);
        new(inbuf);
        FailOSErr(OpenDriver(OutDriverName, outRefNum));
        FailOSErr(OpenDriver(InDriverName, inRefNum));
        FailOSErr(SerReset(outRefNum, baud2400 + data8 + stop10 + noParity));
        FailOSErr(SerReset(inRefNum, baud2400 + data8 + stop10 + noParity));
{ make a large input buffer }
        FailOSErr(SerSetBuf(inRefNum, Ptr(serialManagerBuffer), Sizeof(BufferType)));
{ and even with the large input buffer set it up so it will send an xoff when the buffer is full }
{ see the flags structure }
        FailOSErr(SerHShake(inRefNum, flags));
    end;

    procedure Introduction;
        var
            r: Rect;
    begin
        SetRect(r, 5, 40, 500, 310);
        SetTextRect(r);
        ShowText;
        writeln('This program reads and writes to the modem port at 2400 baud.');
        writeln('It uses these protocols:  8 data bits, 1 stop bits, and no parity.');
        writeln('Press the ESC (or `) key to exit.');
    end;

    procedure Main;
        var
            err: OSErr;
            count: Integer;
            ch: Char;
    begin
        err := SerialInit;
        if err = noErr then
            begin
                ch := AvailChar;
                while (ch <> EscapeChar) and (ch <> BackTicChar) do
                    begin
                        if Ord(ch) <> 0 then
                            begin
                                SerialWrite(ch);
                                if echo then
                                    write(ch)
                            end;
                        count := SerialCharsAvail;
{ see what happens if you comment out the SerHShake and leave this code in }
{    if count > (bufferlen div 2) then }
{    begin }
{    writeln; }
{    writeln('were are getting full warning count =', count, ' if this = buflen-1 chances are we overran'); }
{    end; }
                        if count <> 0 then
                            begin
                                GetSerialChars(count);
                                DisplayBuff(count)
                            end;
                        ch := AvailChar;
                    end;     {while}
            end
        else
            writeln('The serial initializations have failed, id = ', err);
    end;

begin
    Introduction;
    Main;
    CleanUp
end